home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Language/OS - Multiplatform Resource Library
/
LANGUAGE OS.iso
/
tcl
/
tcl70b2.lha
/
tcl7.0b2
/
tclTest.c
< prev
next >
Wrap
C/C++ Source or Header
|
1993-07-08
|
13KB
|
445 lines
/*
* tclTest.c --
*
* This file contains C command procedures for a bunch of additional
* Tcl commands that are used for testing out Tcl's C interfaces.
* These commands are not normally included in Tcl applications;
* they're only used for testing.
*
* Copyright (c) 1993 The Regents of the University of California.
* All rights reserved.
*
* Permission is hereby granted, without written agreement and without
* license or royalty fees, to use, copy, modify, and distribute this
* software and its documentation for any purpose, provided that the
* above copyright notice and the following two paragraphs appear in
* all copies of this software.
*
* IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY FOR
* DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT
* OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF THE UNIVERSITY OF
* CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
*
* THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES,
* INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
* AND FITNESS FOR A PARTICULAR PURPOSE. THE SOFTWARE PROVIDED HEREUNDER IS
* ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION TO
* PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS.
*/
#ifndef lint
static char rcsid[] = "$Header: /user6/ouster/tcl/RCS/tclTest.c,v 1.6 93/07/08 09:59:28 ouster Exp $ SPRITE (Berkeley)";
#endif /* not lint */
#include "tclInt.h"
/*
* The variable below holds a startup script to be executed at the
* beginning of the application.
*/
char initCmd[] =
"if [file exists [info library]/init.tcl] {\n\
source [info library]/init.tcl\n\
} else {\n\
set msg \"can't find [info library]/init.tcl; perhaps you need to\\n\"\n\
append msg \"install Tcl or set your TCL_LIBRARY environment \"\n\
append msg \"variable?\"\n\
error $msg\n\
}";
/*
* The following variable is a special hack that allows applications
* to be linked using the procedure "main" from the Tcl library. The
* variable generates a reference to "main", which causes main to
* be brought in from the library (and all of Tcl with it).
*/
extern int main();
int *tclDummyMainPtr = (int *) main;
/*
* Dynamic string shared by TestdcallCmd and DelCallbackProc; used
* to collect the results of the various deletion callbacks.
*/
static Tcl_DString delString;
static Tcl_Interp *delInterp;
/*
* Forward declarations for procedures defined later in this file:
*/
static void CmdDelProc1 _ANSI_ARGS_((ClientData clientData));
static void CmdDelProc2 _ANSI_ARGS_((ClientData clientData));
static int CmdProc1 _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int argc, char **argv));
static int CmdProc2 _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int argc, char **argv));
static void DelCallbackProc _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp));
static int TestcmdinfoCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int argc, char **argv));
static int TestdcallCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int argc, char **argv));
static int TestlinkCmd _ANSI_ARGS_((ClientData dummy,
Tcl_Interp *interp, int argc, char **argv));
/*
*----------------------------------------------------------------------
*
* Tcl_AppInit --
*
* This procedure performs application-specific initialization.
* Most applications, especially those that incorporate additional
* packages, will have their own version of this procedure.
*
* Results:
* Returns a standard Tcl completion code, and leaves an error
* message in interp->result if an error occurs.
*
* Side effects:
* Depends on the startup script.
*
*----------------------------------------------------------------------
*/
int
Tcl_AppInit(interp)
Tcl_Interp *interp; /* Interpreter for application. */
{
/*
* Calls to init procedures for various included packages should
* appear below, if there are any included packages:
*/
Tcl_CreateCommand(interp, "testcmdinfo", TestcmdinfoCmd, (ClientData) 0,
(Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "testdcall", TestdcallCmd, (ClientData) 0,
(Tcl_CmdDeleteProc *) NULL);
Tcl_CreateCommand(interp, "testlink", TestlinkCmd, (ClientData) 0,
(Tcl_CmdDeleteProc *) NULL);
/*
* Execute a start-up script.
*/
return Tcl_Eval(interp, initCmd);
}
/*
*----------------------------------------------------------------------
*
* TestdcallCmd --
*
* This procedure implements the "testdcall" command. It is used
* to test Tcl_CallWhenDeleted.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* Creates and deletes interpreters.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
static int
TestdcallCmd(dummy, interp, argc, argv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
char **argv; /* Argument strings. */
{
int i;
delInterp = Tcl_CreateInterp();
Tcl_DStringInit(&delString);
for (i = 1; i < argc; i++) {
Tcl_CallWhenDeleted(delInterp, DelCallbackProc, (ClientData) argv[i]);
}
Tcl_DeleteInterp(delInterp);
Tcl_DStringResult(interp, &delString);
return TCL_OK;
}
/*
* The deletion callback used by TestdcallCmd:
*/
static void
DelCallbackProc(clientData, interp)
ClientData clientData; /* String value to append to
* delString. */
Tcl_Interp *interp; /* Interpreter being deleted. */
{
char *string = (char *) clientData;
Tcl_DStringAppendElement(&delString, string);
if (interp != delInterp) {
Tcl_DStringAppendElement(&delString, "bogus interpreter argument!");
}
}
/*
*----------------------------------------------------------------------
*
* TestcmdinfoCmd --
*
* This procedure implements the "testcmdinfo" command. It is used
* to test Tcl_GetCmdInfo, Tcl_SetCmdInfo, and command creation
* and deletion.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* Creates and deletes various commands and modifies their data.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
static int
TestcmdinfoCmd(dummy, interp, argc, argv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
char **argv; /* Argument strings. */
{
Tcl_CmdInfo info;
if (argc != 3) {
Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
" option cmdName\"", (char *) NULL);
return TCL_ERROR;
}
if (strcmp(argv[1], "create") == 0) {
Tcl_CreateCommand(interp, argv[2], CmdProc1, (ClientData) "original",
CmdDelProc1);
} else if (strcmp(argv[1], "delete") == 0) {
Tcl_DStringInit(&delString);
Tcl_DeleteCommand(interp, argv[2]);
Tcl_DStringResult(interp, &delString);
} else if (strcmp(argv[1], "get") == 0) {
if (Tcl_GetCommandInfo(interp, argv[2], &info) ==0) {
interp->result = "??";
return TCL_OK;
}
if (info.proc == CmdProc1) {
Tcl_AppendResult(interp, "CmdProc1", " ",
(char *) info.clientData, (char *) NULL);
} else if (info.proc == CmdProc2) {
Tcl_AppendResult(interp, "CmdProc2", " ",
(char *) info.clientData, (char *) NULL);
} else {
Tcl_AppendResult(interp, "unknown", (char *) NULL);
}
if (info.deleteProc == CmdDelProc1) {
Tcl_AppendResult(interp, " CmdDelProc1", " ",
(char *) info.deleteData, (char *) NULL);
} else if (info.deleteProc == CmdDelProc2) {
Tcl_AppendResult(interp, " CmdDelProc2", " ",
(char *) info.deleteData, (char *) NULL);
} else {
Tcl_AppendResult(interp, " unknown", (char *) NULL);
}
} else if (strcmp(argv[1], "modify") == 0) {
info.proc = CmdProc2;
info.clientData = (ClientData) "new_command_data";
info.deleteProc = CmdDelProc2;
info.deleteData = (ClientData) "new_delete_data";
if (Tcl_SetCommandInfo(interp, argv[2], &info) == 0) {
interp->result = "0";
} else {
interp->result = "1";
}
} else {
Tcl_AppendResult(interp, "bad option \"", argv[1],
"\": must be create, delete, get, or modify",
(char *) NULL);
return TCL_ERROR;
}
return TCL_OK;
}
/*ARGSUSED*/
static int
CmdProc1(clientData, interp, argc, argv)
ClientData clientData; /* String to return. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
char **argv; /* Argument strings. */
{
Tcl_AppendResult(interp, "CmdProc1 ", (char *) clientData,
(char *) NULL);
return TCL_OK;
}
/*ARGSUSED*/
static int
CmdProc2(clientData, interp, argc, argv)
ClientData clientData; /* String to return. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
char **argv; /* Argument strings. */
{
Tcl_AppendResult(interp, "CmdProc2 ", (char *) clientData,
(char *) NULL);
return TCL_OK;
}
static void
CmdDelProc1(clientData)
ClientData clientData; /* String to save. */
{
Tcl_DStringInit(&delString);
Tcl_DStringAppend(&delString, "CmdDelProc1 ", -1);
Tcl_DStringAppend(&delString, (char *) clientData, -1);
}
static void
CmdDelProc2(clientData)
ClientData clientData; /* String to save. */
{
Tcl_DStringInit(&delString);
Tcl_DStringAppend(&delString, "CmdDelProc2 ", -1);
Tcl_DStringAppend(&delString, (char *) clientData, -1);
}
/*
*----------------------------------------------------------------------
*
* TestLinkCmd --
*
* This procedure implements the "testlink" command. It is used
* to test Tcl_LinkVar and related library procedures.
*
* Results:
* A standard Tcl result.
*
* Side effects:
* Creates and deletes various variable links, plus returns
* values of the linked variables.
*
*----------------------------------------------------------------------
*/
/* ARGSUSED */
static int
TestlinkCmd(dummy, interp, argc, argv)
ClientData dummy; /* Not used. */
Tcl_Interp *interp; /* Current interpreter. */
int argc; /* Number of arguments. */
char **argv; /* Argument strings. */
{
static int intVar = 43;
static int boolVar = 4;
static double realVar = 1.23;
static char *stringVar = NULL;
char buffer[TCL_DOUBLE_SPACE];
int writable;
if (argc < 2) {
Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
" option ?arg arg arg?\"", (char *) NULL);
return TCL_ERROR;
}
if (strcmp(argv[1], "create") == 0) {
if (Tcl_LinkVar(interp, "int", (char *) &intVar, TCL_LINK_INT)
!= TCL_OK) {
return TCL_ERROR;
}
if (Tcl_LinkVar(interp, "real", (char *) &realVar, TCL_LINK_DOUBLE)
!= TCL_OK) {
return TCL_ERROR;
}
if (Tcl_LinkVar(interp, "bool", (char *) &boolVar, TCL_LINK_BOOLEAN)
!= TCL_OK) {
return TCL_ERROR;
}
if (Tcl_LinkVar(interp, "string", (char *) &stringVar, TCL_LINK_STRING)
!= TCL_OK) {
return TCL_ERROR;
}
} else if (strcmp(argv[1], "delete") == 0) {
Tcl_UnlinkVar(interp, "int");
Tcl_UnlinkVar(interp, "real");
Tcl_UnlinkVar(interp, "bool");
Tcl_UnlinkVar(interp, "string");
} else if (strcmp(argv[1], "get") == 0) {
sprintf(buffer, "%d", intVar);
Tcl_AppendElement(interp, buffer);
Tcl_PrintDouble(interp, realVar, buffer);
Tcl_AppendElement(interp, buffer);
sprintf(buffer, "%d", boolVar);
Tcl_AppendElement(interp, buffer);
Tcl_AppendElement(interp, (stringVar == NULL) ? "-" : stringVar);
} else if (strcmp(argv[1], "set") == 0) {
if (argc != 6) {
Tcl_AppendResult(interp, "wrong # args: should be \"",
argv[0], " ", argv[1],
"intValue realValue boolValue stringValue\"", (char *) NULL);
return TCL_ERROR;
}
if (argv[2][0] != 0) {
if (Tcl_GetInt(interp, argv[2], &intVar) != TCL_OK) {
return TCL_ERROR;
}
}
if (argv[3][0] != 0) {
if (Tcl_GetDouble(interp, argv[3], &realVar) != TCL_OK) {
return TCL_ERROR;
}
}
if (argv[4][0] != 0) {
if (Tcl_GetInt(interp, argv[4], &boolVar) != TCL_OK) {
return TCL_ERROR;
}
}
if (argv[5][0] != 0) {
if (stringVar != NULL) {
ckfree(stringVar);
}
if (strcmp(argv[5], "-") == 0) {
stringVar = NULL;
} else {
stringVar = ckalloc((unsigned) (strlen(argv[5]) + 1));
strcpy(stringVar, argv[5]);
}
}
} else if (strcmp(argv[1], "writable") == 0) {
if (argv[2][0] != 0) {
if (Tcl_GetBoolean(interp, argv[2], &writable) != TCL_OK) {
return TCL_ERROR;
}
Tcl_LinkedVarWritable(interp, "int", writable);
}
if (argv[3][0] != 0) {
if (Tcl_GetBoolean(interp, argv[3], &writable) != TCL_OK) {
return TCL_ERROR;
}
Tcl_LinkedVarWritable(interp, "real", writable);
}
if (argv[4][0] != 0) {
if (Tcl_GetBoolean(interp, argv[4], &writable) != TCL_OK) {
return TCL_ERROR;
}
Tcl_LinkedVarWritable(interp, "bool", writable);
}
if (argv[5][0] != 0) {
if (Tcl_GetBoolean(interp, argv[5], &writable) != TCL_OK) {
return TCL_ERROR;
}
Tcl_LinkedVarWritable(interp, "string", writable);
}
} else {
Tcl_AppendResult(interp, "bad option \"", argv[1],
"\": should be create, delete, get, set, or writable",
(char *) NULL);
return TCL_ERROR;
}
return TCL_OK;
}